home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Appls / h2j.f < prev    next >
Encoding:
FORTH Source  |  1992-03-25  |  25.5 KB  |  1,078 lines
  1. \ Convert a 'C' include file to a JForth include file.
  2. \ xxx.h to xxx.j
  3. \ This program will prompt an operator if it has trouble
  4. \ parsing a file.
  5. \ The parsing is based on the execution of an experimental
  6. \ "Data Driven Finite State Machine"
  7. \ The "data" are single characters from the file, that are passed
  8. \ to a different parser for each state.
  9. \ The state transitions are intitiated by the parsers.
  10. \ Nesting is available by use of a "state stack".
  11. \
  12. \ Author: Phil Burk, 1986 Delta Research
  13. \ Placed in the Public Domain by the Author.
  14. \
  15. \ MOD: PLB 1/30/87 Add " INCLUDE? :STRUCT JU:C_STRUCT" to .J
  16. \ MOD: PLB 7/26/88 Added USHORT and UBYTE for signed and unsigned.
  17. \          Indent member definitions in .j
  18. \ MOD: PLB 7/11/89 Close INFILE if OUTFILE open fails.
  19. \ MOD: PLB 8/3/89 Add RAWEXPECTECHO ON and USAGE.
  20. \ MOD: PLB 5/20/91 Add support for ENUM, general fixup.
  21. \ MOD: PLB 6/5/91 Fix response to /* xxxx **/
  22. \            Removed ref to JU:C_STRUCT in .J files
  23. \ MOD: PLB 8/9/91 Fix stack underflow.
  24. \ MOD: PLB 8/10/91 Handle (1L<<8), no blank lines in STRUCTs,
  25. \                  Indent members to same level from same line.
  26. \ MOD: PLB 8/10/91 Fix H2J.ABORT, now calls ABORT
  27. \                Clear ()-level and S-EXPR at end of PARSELINE
  28. \ 00001 PLB 3/25/92 Fixed PARSE_|BASE| cuz ENDOF error checks
  29.  
  30. include? ob.string jo:load_ode
  31.  
  32. ANEW TASK-H2J
  33. true if-range-check !  ( turn on object range checking )
  34. true ob-if-check-bind !     ( turn on valid object checking )
  35.  
  36. \ Letter characterizing words.
  37. : ISHEXDIGIT  ( char -- flag , true if valid hex digit )
  38.     dup isdigit
  39.     IF drop true
  40.     ELSE toupper dup ascii G <
  41.          swap ascii @ > AND
  42.     THEN
  43. ;
  44.  
  45. : ISAZ_09  ( char -- flag , Is char a valid 'C' name char, a-z, 0-9, or '_')
  46.     dup ascii _ =
  47.     IF drop true
  48.     ELSE dup isdigit
  49.         IF drop true
  50.         ELSE ?letter
  51.         THEN
  52.     THEN
  53. ;
  54.  
  55. : ASKLINE ( -- addr count , Ask user for line )
  56.     pad 128 expect cr
  57.     pad span @
  58. ;
  59.  
  60.  
  61. \ -----------------------------------------------------------
  62. \ Define a class that associates keywords with indices.
  63. METHOD MATCH:
  64.  
  65. :CLASS OB.COMMANDS <SUPER OB.LIST
  66.  
  67. :M MATCH: ( string -- index true | false , look for matching string )
  68.     false swap
  69.     many: self 0
  70.     DO  dup i at: self $=
  71.         IF  nip i swap true swap leave
  72.         THEN
  73.     LOOP drop
  74. ;M
  75.  
  76. :M PRINT.ELEMENT: ( e# -- , print string )
  77.     at: self $.
  78. ;M
  79.  
  80. ;CLASS
  81.  
  82. \ Declare objects needed.
  83. OB.STRING S-J
  84. OB.STRING S-H
  85. OB.STRING S-KEY
  86. OB.STRING S-NAME
  87. OB.STRING S-TYPE
  88. OB.STRING S-EXPR
  89. OB.STRING S-OPER
  90. OB.STRING S-PREFIX
  91. OB.STRING S-ARRAY
  92.  
  93. OB.ARRAY SM-PARSERS
  94. OB.STACK SM-STACK
  95. OB.LIST  LEGAL-OPS
  96. OB.COMMANDS KEYWORDS
  97. OB.LIST     KEYACTIONS
  98. \ State machine control. ----------------------------------
  99. \ Define allowable states.
  100. 0 dup  constant STATE_|BASE|  ( initial base state )
  101. 1+ dup constant STATE_|S|  ( defining structure name)
  102. 1+ dup constant STATE_|K|  ( accumulating keyword )
  103. 1+ dup constant STATE_|M|  ( structure member being defined )
  104. 1+ dup constant STATE_|ST|  ( structure member struct type being defined )
  105. 1+ dup constant STATE_|MN|  ( structure member name being defined )
  106. 1+ dup constant STATE_|EN|  ( enum member name being defined )
  107. 1+ dup constant STATE_|DN|  ( #define NAME )
  108. 1+ dup constant STATE_|DV|  ( #define name VALUE)
  109. 1+ dup constant STATE_|V|  ( parsing a value )
  110. 1+ dup constant STATE_|C|  ( inside a comment )
  111. 1+ dup constant STATE_|/|  ( detected / )
  112. 1+ dup constant STATE_|*|  ( detected * inside a comment )
  113. 1+ dup constant STATE_|W|  ( eat white space )
  114. 1+ dup constant STATE_|0I|  ( check for hex or octal constants )
  115. 1+ dup constant STATE_|I|  ( parse an integer )
  116. 1+ dup constant STATE_|N|  ( parse a name )
  117. 1+ dup constant STATE_|OP|  ( parse a name )
  118. 1+ dup constant STATE_|"|  ( parse a string )
  119. 1+     constant #STATES
  120.  
  121. \ Variables used in parser.
  122. V: SM-CURSTATE     ( Current state of parser. )
  123. V: BAD-LINE        ( Flag set when unparseable line found)
  124. V: HARD-LINE       ( Flag set when difficult line found)
  125. V: LOOSE-CHAR      ( Character that could not be parsed, gets passed on)
  126. V: IN-STRUCT       ( TRUE if inside a structure definition )
  127. V: IN-ENUM         ( TRUE if inside an enumeration )
  128. V: MEMBER-IS-PTR   ( TRUE if member has the *, and is therefore pointer)
  129. V: #IF-LEVEL       ( Nesting level for compiler conditionals )
  130. V: TYPE-#BYTES     ( Number of bytes for a given structure member )
  131. V: IF-ARRAY        ( TRUE if member is subscripted )
  132. V: ()-LEVEL        ( Tracks level of parens in define values. )
  133. V: ASKED-PREFIX    ( Has user had chance to give prefix )
  134. V: SUPPRESS-LINE   ( Don't print line if blank )
  135. V: IF-COMMENTS     ( True if comments are to be converted. )
  136. V: MEMBER-INDENT   ( level of indentation for previous member )
  137. V: IN-0STRING      ( true if defining a 0string )
  138.  
  139. \ File support ------------------------------
  140. V: J-FILEID
  141. V: H-FILEID
  142.  
  143. : FCLOSE.ID ( addr -- , close variable holding fileid %H )
  144.     dup @ ?dup
  145.     IF fclose   0 swap !
  146.     ELSE drop
  147.     THEN
  148. ;
  149.  
  150. : H2J.CLOSEFILES ( -- )
  151.     j-fileid fclose.id
  152.     h-fileid fclose.id
  153. ;
  154.  
  155. : FILECHECK ( fileid -- , Report error if bad )
  156.     0=
  157.     IF h2j.closefiles
  158.        ." Could not open file!" cr
  159.        ." Usage:     H2J infile.h outfile.j" cr
  160.        abort
  161.     THEN
  162. ;
  163.  
  164. : H2J.READLINE ( -- #CHARS | -1 , read a line from H-FILE )
  165.     H-fileid @ readline: s-h
  166.     type: s-h cr  ( %%% )
  167. ;
  168.  
  169. : H2J-TRAILING  ( -- strip trailing blanks from s-j )
  170.     many: s-j 0
  171.     DO
  172.         last: s-j BL =
  173.         IF
  174.             many: s-j 1- set.many: s-j
  175.         ELSE
  176.             LEAVE
  177.         THEN
  178.     LOOP
  179. ;
  180.  
  181. : H2J.WRITELINE ( -- , write a line to J-FILE )
  182.     h2j-trailing
  183.     many: s-j 0>
  184.     IF
  185. \ line has text so print it
  186.         J-fileid @ writeline: s-j
  187.         type: s-j cr
  188.         clear: s-j
  189.         suppress-line off
  190.     ELSE
  191. \ line is blank
  192. \ are we NOT in a structure
  193.         in-struct @ NOT
  194. \ AND are we NOT suppressing blank lines?
  195.         suppress-line @ not AND
  196.         IF
  197.             suppress-line on  \ don't do two blank lines in a row
  198.             J-fileid @ writeline: s-j
  199.             type: s-j cr
  200.         THEN
  201.     THEN
  202. ;
  203.  
  204. : WRITE2J ( $string -- , write line to J file )
  205.     count load: s-j
  206.     h2j.writeline
  207. ;
  208.  
  209. \ -----------------------------------------------
  210. : BAD.LINE  ( -- , set flags for unparseable line )
  211.     true bad-line !
  212.     " \ %? " count load: s-j 
  213.     count: s-h append: s-j
  214. ;
  215.  
  216. : HARD.LINE ( -- , set flags for difficult line )
  217.     true hard-line !
  218.     " ( %?) " count append: s-j
  219. ;
  220.  
  221. \ Define parsers.
  222. : BAD.PARSER  ( char -- , catch bad parsing )
  223.      ." Bad Parser!" . cr
  224.      break
  225. ;
  226.  
  227. : SM.PUSH  ( -- , push current state )
  228.     sm-curstate @ push: sm-stack
  229. ;
  230.  
  231. : SM.RETURN   ( -- , pop last state )
  232.     pop: sm-stack sm-curstate !
  233. ;
  234.  
  235. : SM.CALL ( new_state -- , nest to new state )
  236.     sm.push
  237.     sm-curstate !
  238. ;
  239.  
  240. : EAT.WHITE  ( -- , Eat white space of line )
  241.     state_|W| sm.call
  242. ;
  243.  
  244. \ PARSERS for various states ------------------------------
  245. \ General parser for Initial state
  246. : PARSE_|BASE|  ( char -- )
  247.     CASE
  248.     EOL OF ENDOF
  249.     ascii / OF state_|/| sm.call ENDOF
  250.     dup isblack
  251.         IF state_|K| sm.call  clear: s-key
  252.            DUP add: s-key \ 00001 added DUP
  253.         ELSE   \ 00001 changd ENDOF to ELSE
  254.            add: s-j 0
  255.         THEN   \ 00001 added THEN
  256.     ENDCASE
  257. ;
  258.  
  259. : PARSE_|K| ( char -- , parse and execute a keyword )
  260.     dup isblack
  261.     IF add: s-key
  262.     ELSE loose-char !  sm.return
  263.          tolower: s-key
  264.          count: s-key  dup pad c!  pad 1+ swap cmove
  265.          pad match: keywords  ( string compare to interpret keyword )
  266.          IF exec: keyactions
  267.          ELSE cr type: s-key space count: s-key . . cr
  268.               ." PARSE_|K| - Unrecognized Keyword" cr
  269.               bad.line
  270.          THEN
  271.          clear: s-key
  272.     THEN
  273. ;
  274.  
  275. : (PARSE_|C|)   ( char -- , handle inside of comment )
  276.  
  277. \ If start of line and in comment put '('
  278.     many: s-j 0=
  279.     IF " ( " count append: s-j
  280.     THEN
  281. \
  282.     CASE
  283.     ascii *
  284.         OF state_|*| sm.call ENDOF
  285. \ Prevent () from messing up JForth comment.
  286.     ascii (  
  287.         OF ascii [ add: s-j  ENDOF
  288.     ascii )
  289.         OF ascii ] add: s-j  ENDOF
  290.     EOL OF ascii ) add: s-j ENDOF    
  291.         add: s-j 0
  292.     ENDCASE
  293. ;
  294.  
  295. : PARSE_|C|   ( char -- , handle inside of comment )
  296.     if-comments @
  297.     IF
  298.         (parse_|c|)
  299.     ELSE
  300.         ascii * =
  301.         IF
  302.             state_|*| sm.call
  303.         ELSE suppress-line on
  304.         THEN
  305.     THEN
  306. ;
  307.  
  308. : PARSE_|/|  ( char -- , test for start of comment )
  309.     sm.return
  310.     CASE
  311.     ascii *
  312.         OF  state_|C| sm.call
  313.             if-comments @
  314.             IF
  315.                 " ( " count append: s-j
  316.             THEN
  317.         ENDOF
  318.     EOL OF ascii / add: s-j
  319.         ENDOF
  320.         ascii / add: s-j add: s-j 0
  321.     ENDCASE
  322. ;
  323.  
  324. : PARSE_|*|  ( char -- , test for end of comment )
  325.     sm.return
  326.     CASE
  327.     ascii / 
  328.         OF
  329.             if-comments @
  330.             IF ascii ) add: s-j
  331.             THEN
  332.             sm.return
  333.         ENDOF
  334.     ascii * 
  335.         OF  
  336.             if-comments @
  337.             IF ascii * add: s-j
  338.             THEN
  339.             state_|*| sm.call \ keep checking for end!
  340.         ENDOF
  341.     EOL OF
  342.             if-comments @
  343.             IF
  344.                 " *)" count append: s-j
  345.             THEN
  346.         ENDOF
  347.         dup loose-char !
  348.         if-comments @
  349.         IF ascii * add: s-j
  350.         THEN
  351.     ENDCASE
  352. ;
  353.  
  354. : PARSE_|W| ( char -- , eat white space )
  355.     dup isblack
  356.     IF loose-char !  sm.return
  357.     ELSE drop
  358.     THEN
  359. ;
  360.  
  361. : PARSE_|DN| ( char -- , accumulate name )
  362.     dup isblack
  363.     IF dup ascii ( =    ( 'C' macro definition?? )
  364.        IF drop bad.line
  365.        ELSE add: s-name
  366.        THEN
  367.     ELSE sm.return EOL = ( Just defining name )
  368.          IF " : " count append: s-j
  369.             count: s-name  append: s-j
  370.             "  ;" count append: s-j
  371.             clear: s-name
  372.          ELSE
  373.             state_|DV| sm.call
  374.             state_|w| sm.call
  375.          THEN
  376.     THEN
  377. ;
  378.  
  379. : PARSE_|0I|  ( char -- , check for HEX integer )
  380.     dup toupper ascii X =
  381.     IF drop " $ " count append: s-expr
  382.     ELSE  loose-char !   ascii 0 add: s-expr
  383.     THEN
  384.     sm.return state_|I| sm.call
  385. ;
  386.  
  387. : PARSE_|"|  ( char -- , keep going till end quote )
  388.     dup add: s-expr
  389.     ascii " =
  390.     IF sm.return
  391.     THEN
  392. ;
  393.  
  394. : <PARSE_|EX|>  ( char flag -- , build an expression, reverse Polish )
  395.     IF add: s-expr
  396.     ELSE bl add: s-expr
  397.          count: s-oper append: s-expr
  398.          bl add: s-expr
  399.          clear: s-oper
  400.          loose-char ! sm.return
  401.     THEN
  402. ;
  403.  
  404. : PARSE_|I| ( char -- , accumulate an integer )
  405.     dup toupper ascii L =
  406.     IF
  407.         \ 123L for long number, just ignore L, stop parsing number
  408.         bl add: s-expr
  409.         drop sm.return
  410.     ELSE
  411.         dup ishexdigit
  412.         <parse_|EX|>
  413.     THEN
  414. ;
  415.  
  416. : PARSE_|N| ( char -- , accumulate an identifier )
  417.     dup isaz_09
  418.     <parse_|EX|>
  419. ;
  420.  
  421. : PARSE_|OP| ( char -- , accumulate an operator )
  422.     dup indexof: legal-ops
  423.     IF drop add: s-oper
  424.     ELSE loose-char ! sm.return
  425.     THEN
  426. ;
  427.  
  428. : NAME.MEMBER ( -- , build name in output stream )
  429.     count: s-prefix append: s-j  ( put prefixes on members )
  430.     count: s-name append: s-j
  431.     clear: s-name
  432.     false member-is-ptr !
  433. ;
  434.  
  435. : DEFINE.ENUMER ( -- , Define a member of an enumeration )
  436.     "    ENUM " count append: s-j
  437.     name.member
  438. ;
  439.  
  440. : OUT.DEFINE ( -- , Output the #define construct in JForth )
  441.     in-enum @
  442.     IF
  443.         s-expr copy: s-j
  444.         " enum-next ! " count append: s-j
  445.         h2j.writeline
  446.         define.enumer
  447.     ELSE
  448.         s-expr copy: s-j
  449.         in-0string @
  450.         IF
  451.             "  0string "
  452.         ELSE
  453.             "  constant "
  454.         THEN count append: s-j
  455.         count: s-name  append: s-j
  456.     THEN
  457.     clear: s-name  clear: s-expr
  458.     clear: s-oper
  459. ;
  460.  
  461. : PEEKNEXT ( -- char , peek ahead at next character )
  462.     ?now.at: s-h
  463.     manyleft: s-h
  464.     IF next: s-h
  465.     ELSE EOL
  466.     THEN
  467.     swap goto: s-h
  468. ;
  469.  
  470. : PARSE_|DV| ( char -- , assemble a define constant )
  471.     dup ascii ( =   
  472.         IF drop 1 ()-level +! 
  473.            ()-level @ 1 >     ( Check for nesting. )
  474.            IF bad.line   0 ()-level !
  475.            THEN exit
  476.         THEN
  477.     dup ascii ) =
  478.         IF drop -1 ()-level +!   exit
  479.         THEN
  480.     dup ascii 0 =    ( Maybe HEX )
  481.         IF drop state_|0I| sm.call exit THEN
  482.     dup ascii - =    ( Negative numbers )
  483.         IF add: s-expr  state_|I| sm.call exit THEN
  484.     dup isdigit
  485.         IF loose-char ! state_|I| sm.call exit THEN
  486.     dup ?letter 
  487.         IF loose-char ! state_|N| sm.call exit THEN
  488. \    dup ascii " = 
  489. \        IF ascii 0 add: s-expr
  490. \           ascii " add: s-expr
  491. \           BL add: s-expr
  492. \           in-0string on
  493. \           state_|"| sm.call exit THEN
  494.     dup ascii / =    ( Start of comment? )
  495.         IF ascii * peeknext =
  496.             IF 32 add: s-name drop 
  497.                    out.define sm.return state_|/| sm.call
  498.                    exit
  499.             THEN
  500.         THEN
  501.     dup indexof: legal-ops    ( Operator ? )
  502.         IF drop loose-char !
  503.            state_|OP| sm.call
  504.            exit
  505.         THEN
  506.     dup EOL = 
  507.         IF  drop out.define 
  508.            sm.return exit
  509.         THEN
  510.     dup ascii , = 
  511.         IF  drop out.define 
  512.            sm.return exit
  513.         THEN
  514.     dup isblack  ( something unexpected!)
  515.         IF  ." Unexpected char = " emit
  516.             bad.line sm.return exit
  517.         THEN
  518. \ White space
  519.     drop state_|W| sm.call
  520. ;
  521.  
  522. : PARSE_|S| ( char -- , parse struct definition )
  523.     dup isblack
  524.     IF add: s-name
  525.     ELSE drop
  526.          " :STRUCT " count append: s-j
  527.          count: s-name  append: s-j
  528.          clear: s-name
  529.          sm.return ( %? )
  530.          true in-struct !
  531.     THEN
  532. ;
  533.  
  534. : REGULAR.MEMBER ( -- , Build NON subscripted member )
  535.     member-is-ptr @
  536.     IF " APTR " count append: s-j
  537.        4 type-#bytes !  ( %? )
  538.     ELSE  count: s-type append: s-j
  539.     THEN
  540.     name.member
  541. ;
  542.  
  543. : ARRAY.MEMBER ( -- , Define member that is an array of something )
  544.     count: s-array append: s-j
  545.     member-is-ptr @
  546.     IF 4
  547.     ELSE type-#bytes @
  548.     THEN
  549.     dup 1 >
  550.     IF  32 add: s-j  
  551.         ascii 0 +  ( convert to char )
  552.         add: s-j
  553.         "  * " count append: s-j
  554.     ELSE drop
  555.     THEN
  556.     "  BYTES " count append: s-j
  557.     name.member
  558. ;
  559.  
  560.  
  561. : DEFINE.MEMBER ( -- , Define some member of a structure )
  562.     many: s-j member-indent !
  563.     if-array @
  564.     IF array.member
  565.     ELSE regular.member
  566.     THEN false if-array !
  567. ;
  568.         
  569. : PARSE_|ST| ( char -- , accumulate structure member struct type )
  570.     dup add: s-type
  571.     isaz_09 NOT
  572.     IF sm.return
  573.     THEN
  574. ;
  575.  
  576. : PARSE_|MN| ( char -- , parse member name definition )
  577.     dup isaz_09 
  578.     IF add: s-name exit THEN
  579.     dup ascii * =
  580.         IF true member-is-ptr ! drop
  581.            eat.white exit
  582.         THEN
  583.     dup ascii , =
  584.         IF  drop define.member
  585.             h2j.writeline
  586.             eat.white
  587.         \ indent next member same as previous
  588.             member-indent @ 0
  589.             DO BL add: s-j
  590.             LOOP
  591.             exit
  592.         THEN
  593.     dup isblack NOT
  594.         IF drop eat.white exit
  595.         THEN
  596.     dup ascii ; = over EOL = OR
  597.         IF  drop define.member 
  598.             sm.return exit
  599.         THEN
  600.     dup ascii [ =
  601.         IF ( array declaration !! )
  602.            drop ascii ] word: s-h
  603.            count load: s-array hard.line
  604.            true if-array !
  605.            exit
  606.         THEN
  607.         drop bad.line
  608. ;
  609.  
  610. : PARSE_|EN| ( char -- , parse enum name definition )
  611.     dup isaz_09 
  612.     IF add: s-name exit THEN
  613.     dup ascii , =
  614.         IF  drop define.enumer
  615.             h2j.writeline
  616.             sm.return
  617.             state_|EN| sm.call
  618.             state_|W| sm.call
  619.             exit
  620.         THEN
  621.     dup ascii = =
  622.         IF  drop
  623.             sm.return
  624.             state_|EN| sm.call
  625.             state_|W| sm.call
  626.             state_|DV| sm.call
  627.             state_|W| sm.call
  628.             exit
  629.         THEN
  630.     dup ascii { =
  631.         IF  drop
  632.             exit
  633.         THEN
  634.     dup ascii } =
  635.         IF  drop
  636.             exit
  637.         THEN
  638.     dup ascii ; =
  639.         IF  drop sm.return
  640.             in-enum off
  641.             in-0string off
  642.             exit
  643.         THEN
  644.     dup ascii / =
  645.         IF drop state_|/| sm.call exit
  646.         THEN
  647.     dup isblack NOT
  648.         IF drop eat.white exit
  649.         THEN
  650.     ." Bad char = " emit bad.line
  651. ;
  652.        
  653. : SM.INIT  ( -- , Initialize State Machine )
  654.     #states new: sm-parsers
  655.     32 new: sm-stack
  656.     state_|BASE| sm-curstate !
  657.     ' bad.parser fill: sm-parsers  ( default parser )
  658.     ' parse_|BASE| state_|BASE| to: sm-parsers
  659.     ' parse_|K|    state_|K|  to: sm-parsers
  660.     ' parse_|DN|   state_|DN| to: sm-parsers
  661.     ' parse_|DV|   state_|DV| to: sm-parsers
  662.     ' parse_|S|    state_|S|  to: sm-parsers
  663.     ' parse_|BASE| state_|M|  to: sm-parsers
  664.     ' parse_|ST|   state_|ST| to: sm-parsers
  665.     ' parse_|MN|   state_|MN| to: sm-parsers
  666.     ' parse_|EN|   state_|EN| to: sm-parsers
  667.     ' parse_|C|    state_|C|  to: sm-parsers
  668.     ' parse_|/|    state_|/|  to: sm-parsers
  669.     ' parse_|*|    state_|*|  to: sm-parsers
  670.     ' parse_|W|    state_|W|  to: sm-parsers
  671.     ' parse_|0I|   state_|0I| to: sm-parsers
  672.     ' parse_|I|    state_|I|  to: sm-parsers
  673.     ' parse_|N|    state_|N|  to: sm-parsers
  674.     ' parse_|OP|   state_|OP| to: sm-parsers
  675.     ' parse_|"|    state_|"|  to: sm-parsers
  676. ;
  677.  
  678. \ Define keyword interpretation.
  679. : ACT.#DEFINE  ( -- action for #define )
  680.     state_|DN| sm.call
  681.     state_|W| sm.call
  682. ;
  683.  
  684. : ASK.PREFIX ( -- , Ask user for prefix to prepend to structure members. )
  685.     asked-prefix @ NOT
  686.     IF  true asked-prefix !
  687.          cr ." Enter optional prefix for unique structure member names:" cr
  688.          ." Examples might be 'nw_' or 'lr_' ." cr
  689.          askline ( addr count )
  690.          dup 0>
  691.          IF "  ( %M JForth prefix ) " count append: s-j
  692.          THEN
  693.          load: s-prefix
  694.     THEN
  695. ;
  696.  
  697. : ACT.STRUCT  ( -- ,  action for struct )
  698.     in-struct @
  699.     IF  ask.prefix
  700.         " STRUCT " count load: s-type
  701.         state_|MN| sm.call
  702.         state_|W|  sm.call
  703.         state_|ST| sm.call  ( structure type )
  704.         state_|W| sm.call
  705.     ELSE state_|S| sm.call
  706.         state_|W| sm.call
  707.         true in-struct !
  708.         false asked-prefix !
  709.         h2j.writeline ( force blank line before )
  710.     THEN
  711. ;
  712.  
  713. : ACT.ENUM  ( -- ,  action for enum )
  714.     h2j.writeline ( force blank line before )
  715.     " 0 enum-next ! " write2j
  716.     state_|EN| sm.call
  717.     state_|W| sm.call
  718.     true in-enum !
  719.     false asked-prefix !
  720. ;
  721.  
  722. : <ACT.MEMBER>  ( #bytes string -- , parse simple structure members )
  723.     count load: s-type
  724.     type-#bytes !
  725.     ask.prefix
  726.     state_|MN| sm.call
  727.     state_|W|  sm.call
  728. ;
  729.  
  730. \ Implement common member types.
  731. : ACT.LONG ( -- )
  732.     4 " LONG " <act.member>
  733. ;
  734. : ACT.ULONG ( -- )
  735.     4 " ULONG " <act.member>
  736. ;
  737. : ACT.APTR ( -- )
  738.     4 " APTR " <act.member>
  739. ;
  740. : ACT.SHORT ( -- )
  741.     2 " SHORT " <act.member>
  742. ;
  743. : ACT.USHORT ( -- )
  744.     2 " USHORT " <act.member>
  745. ;
  746. : ACT.BYTE ( -- )
  747.     1 " BYTE " <act.member>
  748. ;
  749. : ACT.UBYTE ( -- )
  750.     1 " UBYTE " <act.member>
  751. ;
  752.  
  753. : ACT.EXTERN ( -- , IGNORE )
  754. ;
  755.  
  756. : ACT.{ ( -- )
  757. ;
  758.  
  759. : ACT.}; ( -- , terminate structure def if in )
  760.     in-struct @ IF
  761.         false in-struct !  ( set to be outside of structure definition )
  762.         " ;STRUCT " count append: s-j
  763.         h2j.writeline  ( force one blank line for FILE? )
  764.     ELSE
  765.         in-enum @
  766.         IF
  767.             in-enum off
  768.         ELSE
  769.             bad.line
  770.         THEN
  771.     THEN
  772. ;
  773.  
  774. : <ACT.#IFDEF> ( S1 S2 -- , build a name )
  775.     swap count load: s-j
  776.     ' 0= smart.word: s-h  ( get all )
  777.     count append: s-j
  778.     count append: s-j
  779.     1 #if-level +!
  780. ;
  781.  
  782. : ACT.#IFDEF ( -- , Build the equivalent to #IFDEF )
  783.     " EXISTS? " "  .IF" <act.#ifdef>
  784. ;
  785.  
  786. : ACT.#IFNDEF ( -- , Build the equivalent to #IFDEF )
  787.     " EXISTS? " "  NOT .IF" <act.#ifdef>
  788. ;
  789.  
  790. : ACT.#ELSE ( -- , Build equivalent to #ELSE )
  791.     " .ELSE " count load: s-j
  792. ;
  793.  
  794. : ACT.#ENDIF ( -- , Build equivalent to #ENDIF )
  795.     " .THEN "
  796.     count load: s-j
  797.     -1 #if-level +!
  798.     ' 0= smart.word: s-h drop
  799. ;
  800.  
  801. : ACT.#INCLUDE ( -- , Build equivalent to #INCLUDE )
  802.     " include ji:" count load: s-j
  803. \ Convert file name:   "name.h"  to  ji:name.j
  804.     ' 0= smart.word: s-h
  805.     count load: s-name
  806.     ascii " strip: s-name
  807.     32      strip: s-name
  808.     ascii < strip: s-name
  809.     ascii > strip: s-name
  810.     many: s-name 1- dup
  811.     at: s-name ascii h =
  812.     IF ascii j swap to: s-name 
  813.     ELSE drop
  814.     THEN
  815.     count: s-name append: s-j
  816. ;
  817.  
  818. : ACT.#IF ( -- , Build equivalent to #IF )
  819. ;
  820.  
  821. : ADD.KEYWORD ( string cfa -- )
  822.     add: keyactions
  823.     add: keywords
  824. ;
  825.  
  826. : KEYWORDS.INIT ( --)
  827.     33 new: keywords
  828.     33 new: keyactions
  829.     " #define" 'c act.#define add.keyword
  830.     " struct"  'c act.struct  add.keyword
  831.     " {"       'c act.{       add.keyword
  832.     " };"      'c act.};      add.keyword
  833.     " #if"     'c act.#if     add.keyword
  834.     " #ifdef"  'c act.#ifdef  add.keyword
  835.     " #ifndef" 'c act.#ifndef add.keyword
  836.     " #else"   'c act.#else   add.keyword
  837.     " #endif"  'c act.#endif  add.keyword
  838.     " #include"  'c act.#include  add.keyword
  839. \ 10
  840.     " long"    'c act.long    add.keyword
  841.     " ulong"   'c act.ulong   add.keyword
  842.     " float"   'c act.long    add.keyword
  843.     " bstr"    'c act.aptr    add.keyword
  844.     " aptr"    'c act.aptr    add.keyword
  845.     " strptr"  'c act.aptr    add.keyword
  846.     " bptr"    'c act.long    add.keyword
  847.     " word"    'c act.short   add.keyword
  848.     " uword"   'c act.ushort  add.keyword
  849.     " short"   'c act.short   add.keyword
  850. \ 20
  851.     " ushort"  'c act.ushort  add.keyword
  852.     " count"   'c act.short   add.keyword
  853.     " ucount"  'c act.ushort  add.keyword
  854.     " bool"    'c act.short   add.keyword
  855.     " byte"    'c act.byte    add.keyword
  856.     " ubyte"   'c act.ubyte   add.keyword
  857.     " char"    'c act.byte    add.keyword
  858.     " uchar"   'c act.ubyte   add.keyword
  859.     " text"    'c act.byte    add.keyword
  860.     " extern"  'c act.extern  add.keyword
  861. \ 30
  862.     " enum"    'c act.enum    add.keyword
  863.     " cptr"    'c act.ulong   add.keyword
  864. ;
  865.  
  866. : OPS.INIT  ( -- define legal operators )
  867.     7 new: legal-ops
  868.     ascii + add: legal-ops
  869.     ascii - add: legal-ops
  870.     ascii * add: legal-ops
  871.     ascii / add: legal-ops
  872.     ascii < add: legal-ops
  873.     ascii > add: legal-ops
  874.     ascii | add: legal-ops
  875. ;
  876.  
  877. : HANDLE.BAD.LINE ( -- , Let user enter new line. )
  878.     cr type: s-h cr
  879.     type: s-j cr
  880.     cr ." Above line could not be parsed!!" cr
  881.     ." Would you like to enter it?" Y/N
  882.     IF ." Enter line the way you want it." cr
  883.        askline load: s-j
  884.        "  ( %M ) " count append: s-j
  885.     THEN
  886. ;
  887.  
  888. : HANDLE.HARD.LINE ( -- , Let user enter new line. )
  889.     cr type: s-h cr
  890.     type: s-j cr
  891.     cr ." Above line was difficult to parse!!" cr
  892.     ." Would you like to CHANGE it?" Y/N
  893.     IF ." Enter line the way you want it." cr
  894.        askline load: s-j
  895.        "  ( %M ) " count append: s-j
  896.     THEN
  897. ;
  898.  
  899. VARIABLE IF-WATCH
  900. : TRACK.PARSER ( char -- char )
  901.      if-watch @
  902.      IF .s dup ." c= " safe.emit space
  903.         sm-curstate @ at: sm-parsers >name id.
  904.         ?pause
  905.      THEN
  906. ;
  907.  
  908. : H2J.PARSECHAR ( char -- , parse a single character )
  909.      BEGIN
  910.          track.parser
  911.          0 loose-char !
  912.          sm-curstate @ exec: sm-parsers
  913.          loose-char @ ?dup 0=    ( keep going until character accepted )
  914.      UNTIL
  915. ;
  916.  
  917. : H2J.PARSELINE ( -- , Parse a line of input. )
  918.     false bad-line !
  919.     false hard-line !
  920.     reset: s-h
  921.     BEGIN manyleft: s-h 0= 0=
  922.         bad-line @ not AND
  923.     WHILE 
  924.         next: s-h
  925.         h2j.parsechar
  926.     REPEAT
  927.     EOL h2j.parsechar  ( handle EOL )
  928.     bad-line @
  929.     IF handle.bad.line
  930.     THEN
  931.     hard-line @
  932.     IF handle.hard.line
  933.     THEN
  934.     clear: s-type
  935.     clear: s-name
  936.     clear: s-expr
  937.     clear: s-oper
  938.     ()-level off
  939. ;
  940.  
  941. : H2J.OPENFILES  ( <name.h>  <name.j> --IN-- , open files %H )
  942.     fopen dup filecheck h-fileid !
  943.     new fopen dup filecheck j-fileid !
  944. ;
  945.  
  946. \ -------------------------------------------
  947. \ Open a RAW window for single keystroke interaction.
  948. variable H2J-WINDOW
  949. variable H2J-OLDWINDOW
  950. : H2J.OPENWINDOW  ( -- , open a RAW window )
  951.     h2j-window @ 0=
  952.     if-watch @ 0= AND
  953.     IF  " RAW:0/20/630/120/H2J by Phil Burk in JForth"
  954.         $fopen ?dup
  955.         IF  consoleout @ h2j-oldwindow !
  956.             dup h2j-window !
  957.             console!
  958.         ELSE ." Warning! - could not open RAW window!" cr
  959.         THEN
  960.     ELSE ." Window already open!" cr
  961.     THEN
  962. ;
  963.  
  964. : H2J.CLOSEWINDOW  ( -- , close window if open )
  965.     h2j-window @ ?dup
  966.     IF fclose
  967.         h2j-oldwindow @ console!
  968.         h2j-window off
  969.     THEN
  970. ;
  971. \ --------------------------------------------
  972.  
  973. 128 constant SIZE_PSTR
  974. : H2J.TERM ( -- )
  975.     h2j.closewindow
  976.     free: s-j
  977.     free: s-h
  978.     free: s-key
  979.     free: s-name
  980.     free: s-type
  981.     free: s-expr
  982.     free: s-oper
  983.     free: s-prefix
  984.     free: s-array
  985.     free: sm-parsers
  986.     free: sm-stack
  987.     free: keywords
  988.     free: keyactions
  989.     free: legal-ops
  990.     h2j.closefiles
  991. ;
  992.  
  993. : H2J.ABORT  ( -- )
  994.     ['] (abort) is abort
  995.     h2j.term
  996.     abort
  997. ;
  998.  
  999. : H2J.INIT ( -- , Setup the objects )
  1000.     ob.init  ( setup object stack )
  1001.     ['] h2j.abort is abort
  1002.     128 new: s-j   ( allocate data space )
  1003.     128 new: s-h
  1004.     size_pstr new: s-key
  1005.     size_pstr new: s-name
  1006.     size_pstr new: s-type
  1007.     size_pstr new: s-expr
  1008.     size_pstr new: s-oper
  1009.     size_pstr new: s-prefix
  1010.     size_pstr new: s-array
  1011.     false in-struct !
  1012.     false bad-line !
  1013.     0 #if-level !
  1014.     sm.init
  1015.     keywords.init
  1016.     ops.init
  1017.     h2j.openwindow
  1018. ;
  1019.  
  1020. : (H2J) ( -- , assume files already open )
  1021.     if-comments @ 0=
  1022.     IF ." IF-COMMENTS set to FALSE" cr
  1023.     THEN
  1024.     h2j.init
  1025.     " \ AMIGA JForth Include file." write2j
  1026.     " decimal" write2j
  1027.     depth >r
  1028.     BEGIN
  1029.         ." ---------------------------" cr
  1030.         h2j.readline -1 >
  1031.     WHILE
  1032.         h2j.parseline
  1033.         h2j.writeline
  1034.         depth r@ - abort" H2J - change in stack depth!"
  1035.         ?pause
  1036.     REPEAT
  1037.     rdrop
  1038.     h2j.term
  1039. ;
  1040.  
  1041. : H2J ( <name.h>  <name.j> --IN-- , Convert .h file to .j file )
  1042.     cr ." ----------------=< H2J V2.0>=------------------------"
  1043.     cr ." Convert 'C' include file to JForth include file."
  1044.     cr ." H2J written by Phil Burk of Delta Research"
  1045.     cr ." This code may be freely redistributed for use with"
  1046.     cr ." JForth Professional 2.0 from Delta Research"
  1047.     cr ." -----------------------------------------------------" cr
  1048.     h2j.openfiles
  1049.     (h2j)
  1050. ;
  1051.  
  1052. : HJ ( <name> -- , prepend CH: and NJI: )
  1053.     fileword
  1054.     " CH:" pad $move
  1055.     dup count pad $append
  1056.     " .h" count pad $append
  1057.     pad $fopen dup filecheck h-fileid !
  1058.     " NJI:" pad $move
  1059.     dup count pad $append
  1060.     " .j" count pad $append
  1061.     new pad $fopen dup filecheck j-fileid !
  1062.     (h2j)
  1063.     drop
  1064. ;
  1065.  
  1066. \ For debugging
  1067. : H2J.TEST
  1068.     h2j.init
  1069.     " hello /* wow */ 1234" count load: s-h
  1070. ;
  1071.  
  1072. if.forgotten h2j.term
  1073.  
  1074. exists? CLONE .IF
  1075.     RAWEXPECTECHO ON   ( make sure input is echoed in cloned program )
  1076. .THEN
  1077.  
  1078.